COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 simp1(w) applies a set of rules for simplification of sums and
C00012 ENDMK
C⊗;
;;; simp1(w) applies a set of rules for simplification of sums and
;;; products of variables including recognition of numbers and
;;; collection of terms with numerical coefficients.

;;; simplify(w) applies simp1 to an expression and its subexpression
;;; until there are no further changes.

;;; simp1 uses Dick Gabriel's %match and %instantiate functions that
;;; live in MATCH.>[AID,RPG].

(declare 
	 (special *u *v *w ?x ?y *z)
	 (*expr %instantiate)
	 (*lexpr %match))

(defun if macro (l)(cons 'cond (ifxxx1 (cdr l))))

(declare
 (defun ifxxx1 (u) (cond ((null u) nil) ((null (cdr u)) (list (list t (car u))))
 (t (cons (list (car u) (cadr u)) (ifxxx1 (cddr u)))))))

(DEFUN SIMP1 (W) 
       (IF (%MATCH '(TIMES *) W)
	   (IF (%MATCH '(TIMES * 0 *) W)
	       0
	       (%MATCH '(TIMES *U 1 *V) W)
	       (%INSTANTIATE '(TIMES *U *V))
	       (%MATCH '(TIMES) W)
	       1
	       (%MATCH '(TIMES ?X) W)
	       ?X
	       (%MATCH '(TIMES *U (TIMES *V) *W) W)
	       (%INSTANTIATE '(TIMES *U *V *W))
	       (%MATCH '(TIMES *U
			       (RESTRICT ?X 'NUMBERP)
			       *V
			       (RESTRICT ?Y 'NUMBERP)
			       *W)
		       W)
	       (CONS 'TIMES
		     (CONS (TIMES ?X ?Y) (APPEND *U *V *W)))
		(and
	       (%MATCH '(TIMES *U (RESTRICT ?X 'NUMBERP) *V)
		       W)
		(not (null *u)))
	       (%INSTANTIATE '(TIMES ?X *U *V))
	(and distrib (%match '(times *u (plus *v) *w) w))
	(cons 'plus (mapcar (function (lambda (z) (cons 'times (cons
z (append *u *w))))) *v))
	       W)

	   (%MATCH '(PLUS *) W)
	   (IF (%MATCH '(PLUS *U (PLUS *V) *W) W)
	       (%INSTANTIATE '(PLUS *U *V *W))
	       (%MATCH '(PLUS) W)
	       0
	       (%MATCH '(PLUS ?X) W)
	       ?X
	       (%MATCH '(PLUS *U 0 *V) W)
	       (%INSTANTIATE '(PLUS *U *V))
	       (%MATCH '(PLUS *U
			      (RESTRICT ?X 'NUMBERP)
			      *V
			      (RESTRICT ?Y 'NUMBERP)
			      *W)
		       W)
	       (CONS 'PLUS
		     (CONS (PLUS ?X ?Y) (APPEND *U *V *W)))
		(%match '(plus *u ?x *v (times (restrict ?y 'numberp) ?x) *w) w)
		(cons 'plus (cons (list 'times (add1 ?y) ?x) (append *u *v *w)))
		(%match '(plus *u (times (restrict ?y 'numberp) ?x) *v ?x *w) w)
		(cons 'plus (cons (list 'times (add1 ?y) ?x) (append *u *v *w)))
		(%match '(plus *u ?x *v ?x *w) w)
		(%instantiate '(plus (times 2 ?x) *u *v *w))
	       (%MATCH '(PLUS *U
			      (TIMES (RESTRICT ?X 'NUMBERP) *V)
			      *W
			      (TIMES (RESTRICT ?Y 'NUMBERP) *V)
			      *Z)
		       W)
	       (CONS 'PLUS
		     (CONS (CONS 'TIMES (CONS (PLUS ?X ?Y) *V))
			   (APPEND *U *W *Z)))
	       (OR (%MATCH '(PLUS *U
				  (TIMES *V)
				  *W
				  (TIMES (RESTRICT ?X 'NUMBERP)
					 *V)
				  *z)
			   W)
		   (%MATCH '(PLUS *U
				  (TIMES (RESTRICT ?X 'NUMBERP)
					 *V)
				  *W
				  (TIMES *V)
				  *z)
			   W))
	       (CONS 'PLUS
		     (CONS (CONS 'TIMES (CONS (ADD1 ?X) *V))
			   (APPEND *U *W *Z)))
	       W)
	   (%MATCH '(D *) W)
	   (IF (%MATCH '(D ?X ?X) W)
	       1
	       (%MATCH '(D (RESTRICT ?Y ATOM) ?X) W)
	       0
	       (%MATCH '(D (PLUS *U) ?X) W)
	       (CONS 'PLUS
		     (MAPCAR (function (LAMBDA (Z) (LIST 'D Z ?X)))
			     *U))
	       (%MATCH '(D (TIMES ?Y ?Z) ?X) W)
	       (%INSTANTIATE '(PLUS (TIMES (D ?Y ?X) ?Z)
				    (TIMES ?Y (D ?Z ?X))))
	       (%MATCH '(D (TIMES ?Y *U) ?X) W)
	       (%INSTANTIATE '(PLUS (TIMES (D ?Y X) *U)
				    (TIMES ?Y (D (TIMES *U) ?X))))
	       (%MATCH '(D (TIMES) ?X) W)
	       0
	       W)
	   W))
 

(DEFUN SIMPLIFY (W) 
       ((LAMBDA (W1) 
		(IF (EQ W1 W)
		    (IF (OR (%MATCH '(TIMES *U) W)
			    (%MATCH '(PLUS *U) W))
			((LAMBDA (U) 
				 (IF (EQUAL U (CDR W))
				     W
				     (SIMPLIFY (CONS (CAR W) U))))
			 (MAPCAR (function SIMPLIFY) (CDR W)))
			W1)
		    (SIMPLIFY W1)))
	(SIMP1 W))) 


(setq distrib nil)